﻿{*******************************************************}
{                                                       }
{       项目:DelphiWebMVC                               }
{       文件:MVC.Net                                    }
{       E-Mail:pearroom@yeah.net                        }
{       版权所有 (C) 2019 苏兴迎(PRSoft)                }
{                                                       }
{*******************************************************}
unit MVC.Net;

interface

uses
  System.SysUtils, System.Classes, System.Net.URLClient,
  {$IFDEF MSWINDOWS} Vcl.Forms, Winapi.Windows, {$ENDIF}
  System.Generics.Collections, System.DateUtils, System.Net.HttpClient,
  MVC.DataSet, System.Net.HttpClientComponent, System.Net.Mime, IdHashSHA,
  FireDAC.Stan.Intf, FireDAC.Stan.Option, FireDAC.Stan.Param, FireDAC.Stan.Error,
  FireDAC.DatS, FireDAC.Phys.Intf, FireDAC.DApt.Intf, Data.DB, MVC.JSON,
  FireDAC.Comp.DataSet, FireDAC.Comp.Client, System.JSON, StrUtils;

const
  _SessionKey = '__guid_session';
  _ConnectionTimeout = 1000;
  _ResponseTimeout = 5000;
  _SendTimeout = 5000;

type
  TNetMethod = (sGet, sPost, sPostFile, sNone);

  TResParam = record
    var
      SessionID: string;
      isOK: boolean;
      StatCode: integer; // 200表示成功
      Message_: string;
      Body: string;
    function toDS(ds: TDataSet; isClear: Boolean = false): Boolean;
    function toDSI: IDataSet;
    function O: IJObject;
    function A: IJArray;
    procedure Init;
  end;

  TReqParam = record
    SessionID: string;
    Authorization: string;
    URL: string;
    FileName: string;
    PostParams: string;
    Method: TNetMethod;
    procedure Init;
  end;

  INet = interface
    function Post(URL, params: string): string;
    function PostMedia(URL, filepath: string): string;
    function Get(URL: string): string;
  end;

  TNet = class(TInterfacedObject, INet)
  private
    function getHead: TNetHeaders;
  public
    heads: TDictionary<string, string>;
    SessionID: string;
    function Post(URL, params: string): string;
    function PostMedia(URL, filepath: string): string;
    function Get(URL: string): string;
    constructor Create;
    destructor Destroy; override;

  end;

  TRetMethod = reference to procedure(res: TResParam);
  // 此类为异步访问类

  TNetSyn = class(TThread)
    SessionID: string;
    Authorization: string;
    RetMethod: TRetMethod;
    URL: string;
    FileName: string;
    PostParam: string;
    HttpType: string;
    FIsSyn: Boolean;
    FHeader: TStringList;
  protected
    procedure Execute; override;
  public
    procedure SynRun;
    constructor Create(sReqData: TReqParam; RetMethod: TRetMethod; isSyn: Boolean = true; sHeader: TStringList = nil);
    destructor Destroy; override;
  end;

function IINet: INet;

implementation

uses
  MVC.LogUnit;

function IINet: INet;
begin
  result := TNet.Create as INet;
end;

function TNet.Post(URL: string; params: string): string;
var
  http: TNetHTTPClient;
  PostParm: TStringStream;
  html: TStringStream;
  ret: string;
  request: IHTTPResponse;
  cook: TCookie;
  head: TNetHeaders;
begin
  ret := '';
  if Trim(URL) <> '' then
  begin
    http := TNetHTTPClient.Create(nil);
    {$IF CompilerVersion>32}
    http.ConnectionTimeout := _ConnectionTimeout;
    http.ResponseTimeout := _ResponseTimeout;
    {$IFEND}
    html := TStringStream.Create('', TEncoding.UTF8);
    PostParm := TStringStream.Create(params, TEncoding.UTF8);
    try

      http.UserAgent := 'User-Agent:Mozilla/4.0(compatible;MSIE7.0;WindowsNT5.1;360SE)';
      try
        head := getHead;
        request := http.Post(URL, PostParm, html, head);
        SessionID := '';
        for cook in request.Cookies do
        begin
          if cook.Name = _SessionKey then
          begin
            SessionID := cook.Value;
            break;
          end;
        end;
        ret := (html.DataString);
      except
        on E: Exception do
          ret := '';
      end;
    finally
      PostParm.Free;
      html.Clear;
      FreeAndNil(html);
      FreeAndNil(http);
    end;
  end;
  result := ret;
end;

function TNet.PostMedia(URL, filepath: string): string;
var
  http: TNetHTTPClient;
  req: TMultipartFormData;
  html: TStringStream;
  ret: string;
  request: IHTTPResponse;
  cook: TCookie;
  head: TNetHeaders;
begin
  ret := '';
  if Trim(URL) <> '' then
  begin
    http := TNetHTTPClient.Create(nil);
    {$IF CompilerVersion>32}
    http.ConnectionTimeout := _ConnectionTimeout;
    http.ResponseTimeout := _ResponseTimeout;
    {$IFEND}
    html := TStringStream.Create('', TEncoding.UTF8);
    req := TMultipartFormData.Create();
    try
      req.AddFile('fileName', filepath);
      http.UserAgent := 'User-Agent:Mozilla/4.0(compatible;MSIE7.0;WindowsNT5.1;360SE)';
      try
        http.ContentType := 'multipart/form-data';
        head := getHead;
        request := http.Post(URL, req, html, head);
        SessionID := '';
        for cook in request.Cookies do
        begin
          if cook.Name = _SessionKey then
          begin
            SessionID := cook.Value;
            break;
          end;
        end;
        ret := (html.DataString);
      except
        ret := '';
      end;
    finally
      req.Free;
      html.Clear;
      FreeAndNil(html);
      FreeAndNil(http);
    end;
  end;
  result := ret;
end;

constructor TNet.Create;
begin
  heads := TDictionary<string, string>.Create();
end;

destructor TNet.Destroy;
begin
  heads.Clear;
  heads.Free;
  inherited;
end;

function TNet.Get(URL: string): string;
var
  http: TNetHTTPClient;
  html: TStringStream;
  ret: string;
  request: IHTTPResponse;
  cook: TCookie;
  head: TNetHeaders;
begin
  ret := '';
  if Trim(URL) <> '' then
  begin
    try

      http := TNetHTTPClient.Create(nil);
     {$IF CompilerVersion>32}
      http.ConnectionTimeout := _ConnectionTimeout;
      http.ResponseTimeout := _ResponseTimeout;
    {$IFEND}
      html := TStringStream.Create('', TEncoding.UTF8);

      http.UserAgent := 'User-Agent:Mozilla/4.0(compatible;MSIE7.0;WindowsNT5.1;360SE)';
      try
        head := getHead;
        request := http.Get(URL, html, head);
        SessionID := '';
        for cook in request.Cookies do
        begin
          if cook.Name = _SessionKey then
          begin
            SessionID := cook.Value;
            break;
          end;
        end;
        ret := (html.DataString);
      except
        ret := '';
      end;
    finally
      html.Clear;
      FreeAndNil(html);
      FreeAndNil(http);
    end;
  end;
  result := ret;
end;

function TNet.getHead: TNetHeaders;
var
  headers: TNetHeaders;
  key: string;
  i: integer;
  head: TNameValuePair;
  len: integer;
begin
  len := heads.Count;
  System.SetLength(headers, len);
  i := 0;
  for key in heads.Keys do
  begin
    head.Name := key;
    head.Value := heads[key];
    headers[i] := head;
  end;
  result := headers;
end;

{ TNetSyn }

constructor TNetSyn.Create(sReqData: TReqParam; RetMethod: TRetMethod; isSyn: Boolean; sHeader: TStringList);
begin

  FreeOnTerminate := true;
  self.FIsSyn := isSyn;
  self.RetMethod := RetMethod;
  self.URL := sReqData.URL;
  self.PostParam := sReqData.PostParams;
  self.FileName := sReqData.FileName;
  self.SessionID := sReqData.SessionID;
  self.Authorization := sReqData.Authorization;
  FHeader := sHeader;
  if sReqData.Method <> sPost then
    if sReqData.Method <> sPostFile then
      sReqData.Method := sGet;

  if sReqData.Method = sGet then
    HttpType := 'GET';
  if sReqData.Method = sPost then
    HttpType := 'POST';
  if sReqData.Method = sPostFile then
    HttpType := 'POSTFILE';
  if not self.FIsSyn then
  begin
    SynRun;
  end;
  inherited Create(false);
end;

destructor TNetSyn.Destroy;
begin
  URL := '';
  inherited;
end;

procedure TNetSyn.Execute;
begin
//  SessionID:=Self.SessionID;
  if FIsSyn then
    SynRun;
end;

procedure TNetSyn.SynRun;
var
  ret: TResParam;
  Net: TNet;
  logtext: string;
  Content: string;
  i: Integer;
begin
  ret.Init;
  try
    try
      Net := TNet.Create;
      try
        if (FHeader <> nil) then
        begin
          for i := 0 to FHeader.Count - 1 do
          begin
            Net.heads.Add(FHeader.Names[i], FHeader.ValueFromIndex[i]);
          end;
        end;
        if self.SessionID <> '' then
          Net.heads.Add('Cookie', _SessionKey + '=' + self.SessionID);
        if Authorization <> '' then
          Net.heads.Add('Authorization', Authorization);

        if HttpType.ToUpper = 'GET' then
          Content := Net.Get(URL);
        if HttpType.ToUpper = 'POST' then
          Content := Net.Post(URL, PostParam);
        if HttpType.ToUpper = 'POSTFILE' then
          Content := Net.PostMedia(URL, FileName);

        logtext := URL + #13;
        logtext := logtext + '请求数据:' + PostParam + #13;
        logtext := logtext + '返回数据:' + Content + #13;
        LogDebug(logtext); { 测试日志，关闭不再显示 }

        if Content.Trim <> '' then
        begin
          ret.SessionID := Net.SessionID;
          ret.StatCode := 200;
          ret.Message_ := '请求成功';
          ret.isOK := true;
          ret.Body := Content;
        end
        else
        begin
          ret.isOK := false;
          ret.StatCode := 404;
          ret.Message_ := '网络链接异常！';
          Log('StatCode:' + ret.StatCode.ToString + ':' + ret.Message_);
        end;
      finally
        Net.Free;
      end;
    except
      on E: Exception do
      begin
        Log(E.Message);
        ret.StatCode := 500;
        ret.Message_ := '数据格式异常！';
        Log('StattCode:' + ret.StatCode.ToString + ':' + ret.Message_);
      end;
    end;
  finally
    Synchronize(
      procedure
      begin
        RetMethod(ret);
      end);
  end;
end;

{ TResParam }

procedure TResParam.Init;
begin
  FillChar(self, SizeOf(self), 0);
end;

function TResParam.toDSI: IDataSet;
var
  DataSet: IDataSet;
begin
  DataSet := IIDataSet;
  if self.toDS(DataSet.ds, true) then
    result := DataSet
  else
    result := nil;
end;

function TResParam.A: IJArray;
begin
  Result := IIJArray(self.Body);
end;

function TResParam.O: IJObject;
begin
  Result := IIJObject(self.Body);
end;

function TResParam.toDS(ds: TDataSet; isClear: Boolean = false): Boolean;
var
  JsonJO, jsondata: TJSONObject;
  field: TField;
  fielddef: TFieldDef;
  j, i: integer;
  s: string;
  ja: IJArray;
  JSON: string;
  fieldname: string;
  stype: string;
  sdd: TDateTime;
  sd: string;
  pair: TJSONPair;
  jsonvalue: TJSONValue;

  procedure DbClear;
  begin
    ds.first;
    while not ds.Eof do
      ds.Delete;
  end;

begin
  if (self.StatCode <> 200) then
  begin
    result := false;
    exit;
  end;
  try
    JSON := self.Body;
    if (JSON.Substring(0, 1) = '{') and (JSON.Substring(JSON.Length - 1, 1) = '}') then
    begin
      try

        jsondata := TJSONObject.ParseJSONValue(self.Body) as TJSONObject;
        try
          if jsondata.GetValue('data') = nil then
          begin
            JSON := '[' + jsondata.ToJSON + ']';
          end
          else
          begin
            JSON := jsondata.GetValue('data').ToJSON;
          end;
        finally
          jsondata.Free;
        end;
      except
        self.StatCode := 500;
        self.Message_ := '返回数据不是有效JSON格式或没有包含list节点，注意小写';
        result := false;
        exit;
      end;
    end;
    if (JSON = 'null') or (JSON = '') or (JSON = '[]') or (JSON = '{}') then
    begin
      if ds.Active then
        DbClear;
      result := true;
      exit;
    end;

    ja := IIJArray(JSON);
    if isClear then
    begin
      ds.Close;
      ds.FieldDefs.Clear;
      ds.Fields.Clear;
    end;
    if ja.A.Count > 0 then
    begin
      if (ds.Fields.Count = 0) and (ds.FieldDefs.Count = 0) then
      begin
        for i := 0 to ja.A.Count - 1 do
        begin
          JsonJO := ja.A.Items[i] as TJSONObject;

          for j := 0 to JsonJO.Count - 1 do
          begin
            pair := JsonJO.Pairs[j];

            fielddef := ds.FieldDefs.AddFieldDef;
            fielddef.Name := pair.JsonString.Value;
            if pair.JsonValue is TJSONNumber then
            begin
              stype := pair.JsonValue.Value; // 值
              if Pos('.', stype) > 0 then
                fielddef.DataType := ftCurrency
              else
                fielddef.DataType := ftInteger;
            end
            else if pair.JsonValue is TJSONBool then
            begin
              fielddef.DataType := ftBoolean;
            end
            else if pair.JsonValue is TJSONString then
            begin

              sd := pair.JsonValue.Value;

              if (sd.Length > 8) and (sd.Length < 30) and (TryStrToDateTime(sd, sdd)) then
                fielddef.DataType := ftDateTime
              else
              begin
                fielddef.DataType := ftString;
                fielddef.Size := 5000;
              end;
            end;
          end;
          break;
        end;
      end;
      try

        ds.Close;
        ds.open;
      //  DbClear;


        for i := 0 to ja.A.Count - 1 do
        begin
          ds.Append;
          JsonJO := ja.A.Items[i] as TJSONObject;
          s := JsonJO.ToJSON;
          for j := 0 to ds.Fields.Count - 1 do
          begin
            ds.Fields[j].DisplayWidth := 20;
            fieldname := ds.Fields[j].DisplayLabel;
            if fieldname <> '' then
            begin
              s := '';

              jsonvalue := JsonJO.GetValue(fieldname);
              if jsonvalue <> nil then
              begin
                s := jsonvalue.Value.Replace('\r', #13).Replace('\n', #10);
                if (s.Length > 8) and (s.Length < 30) and (TryStrToDateTime(s, sdd)) then
                begin
                  ds.Fields[j].Value := sdd;
                end
                else if leftStr(fieldname, 2) = 'is' then
                begin
                  ds.Fields[j].Value := s = '1';
                end
                else
                begin
                  if (s <> '') and (s.ToLower <> 'null') and (pos('1988', s) = 0) then
                    ds.Fields[j].AsString := s;
                end;
              end;
            end;
          end;
          ds.Post;
        end;
        ds.first;
      except
        on E: Exception do
        begin
          Log(E.Message);
          self.StatCode := 500;
          self.Message_ := '返回数据格式错误!' + #13 + E.Message;
          result := false;
          exit;
        end;
      end;
    end;
  finally
  end;
  result := true;
end;

{ TReqParam }

procedure TReqParam.Init;
begin
  FillChar(self, SizeOf(self), 0);
end;

end.

